home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / charplot.scm < prev    next >
Text File  |  1999-04-19  |  5KB  |  143 lines
  1. ;;;; "charplot.scm", plotting on character devices for Scheme
  2. ;;; Copyright (C) 1992, 1993 Aubrey Jaffer.
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (require 'sort)
  21.  
  22. (define charplot:rows 24)
  23. (define charplot:columns (output-port-width (current-output-port)))
  24.  
  25. (define charplot:xborder #\_)
  26. (define charplot:yborder #\|)
  27. (define charplot:xaxchar #\-)
  28. (define charplot:yaxchar #\:)
  29. (define charplot:curve1 #\*)
  30. (define charplot:xtick #\.)
  31.  
  32. (define charplot:height (- charplot:rows 5))
  33. (define charplot:width (- charplot:columns 15))
  34.  
  35. (define (charplot:printn! n char)
  36.   (cond ((positive? n)
  37.      (write-char char)
  38.      (charplot:printn! (+ n -1) char))))
  39.  
  40. (define (charplot:center-print! str width)
  41.   (let ((lpad (quotient (- width (string-length str)) 2)))
  42.     (charplot:printn! lpad #\ )
  43.     (display str)
  44.     (charplot:printn! (- width (+ (string-length  str) lpad)) #\ )))
  45.  
  46. (define (scale-it z scale)
  47.   (if (and (exact? z) (integer? z))
  48.       (quotient (* z (car scale)) (cadr scale))
  49.       (inexact->exact (round (/ (* z (car scale)) (cadr scale))))))
  50.  
  51. (define (find-scale isize delta)
  52.   (if (inexact? delta) (set! isize (exact->inexact isize)))
  53.   (do ((d 1 (* d 10)))
  54.       ((<= delta isize)
  55.        (do ((n 1 (* n 10)))
  56.        ((>= (* delta 10) isize)
  57.         (list (* n (cond ((< (* delta 8) isize) 8)
  58.                  ((< (* delta 6) isize) 6)
  59.                  ((< (* delta 5) isize) 5)
  60.                  ((< (* delta 4) isize) 4)
  61.                  ((< (* delta 3) isize) 3)
  62.                  ((< (* delta 2) isize) 2)
  63.                  (else 1)))
  64.           d))
  65.      (set! delta (* delta 10))))
  66.     (set! isize (* isize 10))))
  67.  
  68. (define (charplot:iplot! data xlabel ylabel xmin xscale ymin yscale)
  69.   (define xaxis (- (scale-it ymin yscale)))
  70.   (define yaxis (- (scale-it xmin xscale)))
  71.   (charplot:center-print! ylabel 11)
  72.   (charplot:printn! (+ charplot:width 1) charplot:xborder)
  73.   (newline)
  74.   (set! data (sort! data (lambda (x y) (if (= (cdr x) (cdr y))
  75.                        (< (car x) (car y))
  76.                        (> (cdr x) (cdr y))))))
  77.   (do ((ht (- charplot:height 1) (- ht 1)))
  78.       ((negative? ht))
  79.     (let ((a (make-string (+ charplot:width 1)
  80.               (if (= ht xaxis) charplot:xaxchar #\ )))
  81.       (ystep (if (= 1 (gcd (car yscale) 3)) 2 3)))
  82.       (string-set! a charplot:width charplot:yborder)
  83.       (if (< -1 yaxis charplot:width) (string-set! a yaxis charplot:yaxchar))
  84.       (do ()
  85.       ((or (null? data) (not (>= (cdar data) ht))))
  86.     (string-set! a (caar data) charplot:curve1)
  87.     (set! data (cdr data)))
  88.       (if (zero? (modulo (- ht xaxis) ystep))
  89.       (let* ((v (number->string (/ (* (- ht xaxis) (cadr yscale))
  90.                        (car yscale))))
  91.          (l (string-length v)))
  92.         (if (> l 10)
  93.         (display (substring v 0 10))
  94.         (begin
  95.           (charplot:printn! (- 10 l) #\ )
  96.           (display v)))
  97.         (display charplot:yborder)
  98.         (display charplot:xaxchar))
  99.       (begin
  100.         (charplot:printn! 10 #\ )
  101.         (display charplot:yborder)
  102.         (display #\ )))
  103.       (display a) (newline)))
  104.   (let* ((xstep (if (= 1 (gcd (car xscale) 3)) 10 12))
  105.      (xstep/2 (quotient (- xstep 2) 2))
  106.      (fudge (modulo yaxis xstep)))
  107.     (charplot:printn! 10 #\ ) (display charplot:yborder)
  108.     (charplot:printn! (+ 1 fudge) charplot:xborder)
  109.     (display charplot:yaxchar)
  110.     (do ((i fudge (+ i xstep)))
  111.     ((> (+ i xstep) charplot:width)
  112.      (charplot:printn! (modulo (- charplot:width (+ i 1)) xstep)
  113.                charplot:xborder))
  114.       (charplot:printn! xstep/2 charplot:xborder)
  115.       (display charplot:xtick)
  116.       (charplot:printn! xstep/2 charplot:xborder)
  117.       (display charplot:yaxchar))
  118.     (display charplot:yborder) (newline)
  119.     (charplot:center-print! xlabel (+ 12 fudge (- xstep/2)))
  120.     (do ((i fudge (+ i xstep)))
  121.     ((> (+ i xstep) charplot:width))
  122.       (charplot:center-print! (number->string (/ (* (- i yaxis) (cadr xscale))
  123.                          (car xscale)))
  124.                   xstep))
  125.     (newline)))
  126.  
  127. (define (charplot:plot! data xlabel ylabel)
  128.   (let* ((xmax (apply max (map car data)))
  129.      (xmin (apply min (map car data)))
  130.      (xscale (find-scale charplot:width (- xmax xmin)))
  131.      (ymax (apply max (map cdr data)))
  132.      (ymin (apply min (map cdr data)))
  133.      (yscale (find-scale charplot:height (- ymax ymin)))
  134.      (ixmin (scale-it xmin xscale))
  135.      (iymin (scale-it ymin yscale)))
  136.     (charplot:iplot! (map (lambda (p)
  137.                 (cons (- (scale-it (car p) xscale) ixmin)
  138.                   (- (scale-it (cdr p) yscale) iymin)))
  139.               data)
  140.              xlabel ylabel xmin xscale ymin yscale)))
  141.  
  142. (define plot! charplot:plot!)
  143.